home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / audacity / nyquist / seq.lsp < prev    next >
Encoding:
Lisp/Scheme  |  2010-09-21  |  10.4 KB  |  253 lines
  1. ;; seq.lsp -- sequence control constructs for Nyquist
  2.  
  3. ;; get-srates -- this either returns the sample rate of a sound or a
  4. ;;   vector of sample rates of a vector of sounds
  5. ;;
  6. (defun get-srates (sounds)
  7.   (cond ((arrayp sounds)
  8.          (let ((result (make-array (length sounds))))
  9.            (dotimes (i (length sounds))
  10.                     (setf (aref result i) (snd-srate (aref sounds i))))
  11.            result))
  12.         (t
  13.          (snd-srate sounds))))
  14.  
  15. ; These are complex macros that implement sequences of various types.
  16. ; The complexity is due to the fact that a behavior within a sequence
  17. ; can reference the environment, e.g. (let ((p 60)) (seq (osc p) (osc p)))
  18. ; is an example where p must be in the environment of each member of
  19. ; the sequence.  Since the execution of the sequence elements are delayed,
  20. ; the environment must be captured and then used later.  In XLISP, the
  21. ; EVAL function does not execute in the current environment, so a special
  22. ; EVAL, EVALHOOK must be used to evaluate with an environment.  Another
  23. ; feature of XLISP (see evalenv.lsp) is used to capture the environment
  24. ; when the seq is first evaluated, so that the environment can be used
  25. ; later.  Finally, it is also necessary to save the current transformation
  26. ; environment until later.
  27.  
  28. (defmacro seq (&rest list)
  29.   (cond ((null list)
  30.          (snd-zero (warp-time *WARP*) *sound-srate*))
  31.         ((null (cdr list))
  32.          (car list))
  33.         ((null (cddr list))
  34.          ; (format t "SEQ with 2 behaviors: ~A~%" list)
  35.          `(let* ((first%sound ,(car list))
  36.                 (s%rate (get-srates first%sound)))
  37.             (cond ((arrayp first%sound)
  38.                    (snd-multiseq (prog1 first%sound (setf first%sound nil))
  39.                      #'(lambda (t0)
  40.                         (format t "MULTISEQ's 2nd behavior: ~A~%" ',(cadr list))
  41.                         (with%environment ',(nyq:the-environment)
  42. ;                (display "MULTISEQ 1" t0)
  43.                             (at-abs t0
  44.                                 (force-srates s%rate ,(cadr list)))))))
  45.                   (t
  46.                    ; allow gc of first%sound:
  47.                    (snd-seq (prog1 first%sound (setf first%sound nil))
  48.                      #'(lambda (t0) 
  49. ;                        (format t "SEQ's 2nd behavior: ~A~%" ',(cadr list))
  50.                         (with%environment ',(nyq:the-environment)
  51.                             (at-abs t0
  52.                                 (force-srate s%rate ,(cadr list))))))))))
  53.  
  54.         (t
  55.          `(let* ((nyq%environment (nyq:the-environment))
  56.                  (first%sound ,(car list))
  57.                  (s%rate (get-srates first%sound))
  58.                  (seq%environment (getenv)))
  59.             (cond ((arrayp first%sound)
  60. ;           (print "calling snd-multiseq")
  61.                    (snd-multiseq (prog1 first%sound (setf first%sound nil))
  62.                      #'(lambda (t0)
  63.                         (multiseq-iterate ,(cdr list)))))
  64.                   (t 
  65. ;           (print "calling snd-seq")
  66.                    ; allow gc of first%sound:
  67.                    (snd-seq (prog1 first%sound (setf first%sound nil))
  68.                      #'(lambda (t0)
  69.                         (seq-iterate ,(cdr list))))))))))
  70.  
  71. (defun envdepth (e) (length (car e)))
  72.  
  73. (defmacro myosd (pitch)
  74.   `(let () (format t "myosc env depth is ~A~%" 
  75.                    (envdepth (getenv))) (osc ,pitch)))
  76.  
  77. (defmacro seq-iterate (behavior-list)
  78.   (cond ((null (cdr behavior-list))
  79.          `(eval-seq-behavior ,(car behavior-list)))
  80.         (t
  81.          `(snd-seq (eval-seq-behavior ,(car behavior-list))
  82.                    (evalhook '#'(lambda (t0) 
  83.                                   ; (format t "lambda depth ~A~%" (envdepth (getenv)))
  84.                                   (seq-iterate ,(cdr behavior-list)))
  85.                              nil nil seq%environment)))))
  86.  
  87. (defmacro multiseq-iterate (behavior-list)
  88.   (cond ((null (cdr behavior-list))
  89.          `(eval-multiseq-behavior ,(car behavior-list)))
  90.         (t
  91.          `(snd-multiseq (eval-multiseq-behavior ,(car behavior-list))
  92.                    (evalhook '#'(lambda (t0) 
  93.                                   ; (format t "lambda depth ~A~%" (envdepth (getenv)))
  94.                                   (multiseq-iterate ,(cdr behavior-list)))
  95.                              nil nil seq%environment)))))
  96.  
  97. (defmacro eval-seq-behavior (beh)
  98.   `(with%environment nyq%environment 
  99.                      (at-abs t0
  100.                              (force-srate s%rate ,beh))))
  101.  
  102. (defmacro eval-multiseq-behavior (beh)
  103.   `(with%environment nyq%environment 
  104. ;                (display "MULTISEQ 2" t0)
  105.                      (at-abs t0
  106.                              (force-srates s%rate ,beh))))
  107.  
  108. (defmacro with%environment (env &rest expr)
  109.   `(progv ',*environment-variables* ,env ,@expr))
  110.  
  111.  
  112.  
  113. (defmacro seqrep (pair sound)
  114.   `(let ((,(car pair) 0)
  115.          (loop%count ,(cadr pair))
  116.          (nyq%environment (nyq:the-environment))
  117.          seqrep%closure first%sound s%rate)
  118.      ; note: s%rate will tell whether we want a single or multichannel
  119.      ; sound, and what the sample rates should be.
  120.      (cond ((not (integerp loop%count))
  121.             (error "bad argument type" loop%count))
  122.            (t
  123.             (setf seqrep%closure #'(lambda (t0)
  124. ;          (display "SEQREP" loop%count ,(car pair))
  125.               (cond ((< ,(car pair) loop%count)
  126.                      (setf first%sound 
  127.                            (with%environment nyq%environment
  128.                                              (at-abs t0 ,sound)))
  129.                      ; (display "seqrep" s%rate nyq%environment ,(car pair)
  130.                      ;          loop%count)
  131.                      (if s%rate
  132.                        (setf first%sound (force-srates s%rate first%sound))
  133.                        (setf s%rate (get-srates first%sound)))
  134.                      (setf ,(car pair) (1+ ,(car pair)))
  135.                      ; note the following test is AFTER the counter increment
  136.                      (cond ((= ,(car pair) loop%count)
  137. ;                            (display "seqrep: computed the last sound at"
  138. ;                               ,(car pair) loop%count
  139. ;                               (local-to-global 0))
  140.                             first%sound) ;last sound
  141.                            ((arrayp s%rate)
  142. ;                            (display "seqrep: calling snd-multiseq at"
  143. ;                             ,(car pair) loop%count (local-to-global 0) 
  144. ;                             (snd-t0 (aref first%sound 0)))
  145.                             (snd-multiseq (prog1 first%sound
  146.                                                  (setf first%sound nil))
  147.                                           seqrep%closure))
  148.                            (t
  149. ;                            (display "seqrep: calling snd-seq at"
  150. ;                             ,(car pair) loop%count (local-to-global 0) 
  151. ;                             (snd-t0 first%sound))
  152.                             (snd-seq (prog1 first%sound
  153.                                             (setf first%sound nil))
  154.                                      seqrep%closure))))
  155.                     (t (snd-zero (warp-time *WARP*) *sound-srate*)))))
  156.             (funcall seqrep%closure (local-to-global 0))))))
  157.  
  158.  
  159. (defmacro trigger (input beh)
  160.   `(let ((nyq%environment (nyq:the-environment)))
  161.      (snd-trigger ,input #'(lambda (t0) (with%environment nyq%environment
  162.                             (at-abs t0 ,beh))))))
  163.  
  164. ;; EVENT-EXPRESSION -- the sound of the event
  165. ;;
  166. (setfn event-expression caddr)
  167.  
  168.  
  169. ;; EVENT-HAS-ATTR -- test if event has attribute
  170. ;;
  171. (defun event-has-attr (note attr)
  172.   (expr-has-attr (event-expression note)))
  173.  
  174.  
  175. ;; EXPR-SET-ATTR -- new expression with attribute = value
  176. ;;
  177. (defun expr-set-attr (expr attr value)
  178.   (cons (car expr) (list-set-attr-value (cdr expr) attr value)))
  179.  
  180. (defun list-set-attr-value (lis attr value)
  181.   (cond ((null lis) (list attr value))
  182.     ((eq (car lis) attr)
  183.      (cons attr (cons value (cddr lis))))
  184.     (t
  185.      (cons (car lis)
  186.        (cons (cadr lis) 
  187.          (list-set-attr-value (cddr lis) attr value))))))
  188.  
  189.  
  190. ;; EXPAND-AND-EVAL-EXPR -- evaluate a note, chord, or rest for timed-seq
  191. ;;
  192. (defun expand-and-eval-expr (expr)
  193.   (let ((pitch (member :pitch expr)))
  194.     (cond ((and pitch (cdr pitch) (listp (cadr pitch)))
  195.        (setf pitch (cadr pitch))
  196.        (simrep (i (length pitch))
  197.          (eval (expr-set-attr expr :pitch (nth i pitch)))))
  198.       (t
  199.        (eval expr)))))
  200.  
  201.  
  202. ;; (timed-seq '((time1 stretch1 expr1) (time2 stretch2 expr2) ...))
  203. ;; a timed-seq takes a list of events as shown above
  204. ;; it sums the behaviors, similar to 
  205. ;;     (sim (at time1 (stretch stretch1 expr1)) ...)
  206. ;; but the implementation avoids starting all expressions at once
  207. ;; 
  208. ;; Notes: (1) the times must be in increasing order
  209. ;;   (2) EVAL is used on each event, so events cannot refer to parameters
  210. ;;        or local variables
  211. ;;
  212. (defun timed-seq (score)
  213.   ; check to insure that times are strictly increasing and >= 0 and stretches are >= 0
  214.   (let ((start-time 0) error-msg)
  215.     (dolist (event score)
  216.       (cond ((< (car event) start-time)
  217.              (error (format nil "Out-of-order time in TIMED-SEQ: ~A" event)))
  218.             ((< (cadr event) 0)
  219.              (error (format nil "Negative stretch factor in TIMED-SEQ: ~A" event)))
  220.             (t
  221.              (setf start-time (car event)))))
  222.     ;; remove rests (a rest has a :pitch attribute of nil)
  223.     (setf score (score-select score #'(lambda (tim dur evt)
  224.                                        (expr-get-attr evt :pitch t))))
  225.     (cond ((and score (car score) 
  226.         (eq (car (event-expression (car score))) 'score-begin-end))
  227.        (setf score (cdr score)))) ; skip score-begin-end data
  228.     ; (score-print score) ;; debugging
  229.     (cond ((null score) (s-rest 0))
  230.           (t
  231.            (at (caar score)
  232.                (seqrep (i (length score))
  233.                  (cond ((cdr score)
  234.                         (let (event)
  235.                           (prog1
  236.                             (set-logical-stop
  237.                               (stretch (cadar score)
  238.                                 (setf event (expand-and-eval-expr
  239.                          (caddar score))))
  240.                               (- (caadr score) (caar score)))
  241.                             ;(display "timed-seq" (caddar score) 
  242.                             ;                     (local-to-global 0)
  243.                             ;                     (snd-t0 event)
  244.                             ;                     (- (caadr score) 
  245.                             ;                        (caar score)))
  246.                             (setf score (cdr score)))))
  247.                          (t
  248.                           (stretch (cadar score) (expand-and-eval-expr
  249.                           (caddar score)))))))))))
  250.  
  251.  
  252.  
  253.